PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/ovract.com/OVRACTR.PAS

Pascal/Delphi Source File | 1989-11-22 | 17.0 KB | 638 lines

{
OVRACTR generates reports describing the overlay activity of a Turbo Pascal
5.x program.

To use it, add the unit OVRACT as near as possible to the beginning of the uses
statement of your main program.  Compile the application to create both an
EXE file and a corresponding MAP file and run the program normally.  A file
named ProgName.OVD will be produced, where ProgName is the root name of your
EXE file.  OVRACTR must read the first section of the MAP file (the segment
map) to get certain information. It also reads from the OVD file to get
detailed information about the overlay activity. It doesn't need to access
the EXE or OVR files.

Call OVRACTR as follows:

  OVRACTR [Options] ProgName [>Output]

OVRACTR forces the extension 'MAP' onto ProgName to find the MAP file, and
the extension 'OVD' onto ProgName to find the overlay data file. The overlay
report is written to the standard output and may be redirected to a file or
to the printer. The options are

   /Q   stops OVRACTR from writing status messages while it works.
   /D   produces the detailed report of all overlay activity.
   /S   produces the summary report showing statistics for each unit.
   /O   produces the summary report showing statistics only for overlaid units

The detailed report gives a very basic dump of the events in the OVD file.
For each event it shows the time, name of the unit, offset of the procedure,
and type of event, followed by a list of the names of the units on the load
list.

The summary report is quite a bit more civilized, being a clone of
Kim Kokkonen's OVRSIZ report, with columns added for load count and
reprieve count.

Written by Ron Schuster (CIS 76666,2322).  Copyright (c) 1989.
All rights reserved.  May be distributed freely, but not for a profit.

This program was originally based on the overlay profiler OVRPROF
written by Richard Casey (CIS 72247,151).

Portions of this program originally appeared in OVRSIZ by Kim Kokkonen,
TurboPower Software (CIS 76004,2611), and were used with the permission of
the author.  Copyright (c) 1989, TurboPower Software. All rights reserved.
May be distributed freely, but not for a profit.


Version 1.0, 11/21/89
--------------------
  Initial release.
}

{$R-,S-,I-,V-,F-,B-}

program OVRACTR;
  {-Generate reports of overlay activity from data produced by OVRACT}
uses Dos;
const
  Version = '1.0';                {Version number}
  MaxUnits = 255;                 {Maximum number of units to report}
  NameSize = 15;                  {Maximum reported segment name length}
  BufSize = 1024;                 {Size of text I/O buffer}
  ShowStatus : Boolean = True;    {True to keep status running during operation}
  ShowDetail : Boolean = False;   {True to write detailed dump of overlay events}
  ShowSummary : Boolean = False;  {True to write summary report}
  OverlaysOnly : Boolean = False;  {True to write summary report with overlaid
                                    units only}
  Digits : array[0..$F] of Char = '0123456789ABCDEF';
  DosDelimSet : set of Char = ['\', ':', #0];

type
  UnitNameStr = string[NameSize];
  UnitRecord = record
    Name : UnitNameStr;
    SegClass : Word;
    StatSeg : Word;
    StatLen : LongInt;
    FileOfs : LongInt;
    CodeSize : Word;
    FixupSize : Word;
    EntryPts : Word;
    LoadCount : Word;
    ReprieveCount : Word;
  end;

  Long =
    record
      LowWord, HighWord : Word;
    end;

var
  UnitCount    : Word;
  Units        : array[0..MaxUnits] of UnitRecord;
  StdErr       : text;
  OvrDataFile  : file of Word;
  PSP          : Word;
  Ovr_Heap_Org : Word;
  Ovr_Heap_End : Word;
  Buffer       : array[1..BufSize] of Char; {Text buffer for map file}
  Dname        : PathStr;               {Input OVD file name}
  Mname        : PathStr;               {Input MAP file name}
  Time         : LongInt;

procedure WriteCopyRight;
  {-Copyright notice in object code and on screen}
begin
  WriteLn(StdErr, 'TP5.x Overlay Activity Reporter, by Ron Schuster. Version ', Version);
end;

procedure OpenStdErr;
  {-Open standard error device}
begin
  Assign(StdErr, '');
  Rewrite(StdErr);
  with TextRec(StdErr) do begin
    Handle := 2;
    BufSize := 1;
  end;
end;

procedure Error(Msg : String);
  {-Report error and halt}
begin
  if Msg <> '' then
    WriteLn(StdErr, Msg);
  Halt(1);
end;

procedure InvalidMapError;
  {-Common error}
begin
  Error('Invalid MAP file format');
end;

function HexW(W : Word) : String;
  {-Return hex string for word}
begin
  HexW[0] := #4;
  HexW[1] := Digits[Hi(W) shr 4];
  HexW[2] := Digits[Hi(W) and $F];
  HexW[3] := Digits[Lo(W) shr 4];
  HexW[4] := Digits[Lo(W) and $F];
end;

function HexL(L : LongInt) : String;
  {-Return hex string for LongInt}
begin
  with Long(L) do
    HexL := HexW(HighWord)+HexW(LowWord);
end;

function Long2Str(L : LongInt) : String;
  {-Convert a long/word/integer/byte/shortint to a string}
var
  S : String;
begin
  Str(L, S);
  Long2Str := S;
end;

function StUpcase(S : String) : String;
  {-Return the uppercase of a string}
var
  I : Integer;
begin
  for I := 1 to Length(S) do
    S[I] := Upcase(S[I]);
  StUpcase := S;
end;

function Pad(S : String; Len : Byte) : String;
  {-Return a string right-padded to length len with ch}
var
  O : String;
begin
  if Length(S) >= Len then
    Pad := S
  else begin
    O[0] := Chr(Len);
    Move(S[1], O[1], Length(S));
    FillChar(O[Succ(Length(S))], Len-Length(S), ' ');
    Pad := O;
  end;
end;

function TrimLead(S : String) : String;
  {-Return a string with leading white space removed}
begin
  while (Length(S) > 0) and (S[1] <= ' ') do
    Delete(S, 1, 1);
  TrimLead := S;
end;

function Trim(S : String) : String;
  {-Return a string with leading and trailing white space removed}
begin
  while (Length(S) > 0) and (S[Length(S)] <= ' ') do
    Dec(S[0]);
  while (Length(S) > 0) and (S[1] <= ' ') do
    Delete(S, 1, 1);
  Trim := S;
end;

function GetLong(var S : String; var L : LongInt) : Boolean;
  {-Parse next longint out of line S}
var
  Num : String[8];
  Code : Word;
begin
  S := TrimLead(S);
  Num := '';
  while (Length(S) > 0) and (Pos(S[1], Digits) <> 0) do begin
    Num := Num+S[1];
    Delete(S, 1, 1);
  end;
  if Length(Num) = 0 then begin
    GetLong := False;
    Exit;
  end;
  if (Length(S) > 0) and (Upcase(S[1]) = 'H') then begin
    Num := '$'+Num;
    Delete(S, 1, 1);
  end;
  Val(Num, L, Code);
  GetLong := (Code = 0);
end;

function GetName(var S, Name : String) : Boolean;
  {-Parse next alphanumeric name from string s}
begin
  S := TrimLead(S);
  Name := '';
  while (Length(S) > 0) and (S[1] > ' ') do begin
    if Length(Name) < NameSize then
      Name := Name+S[1];
    Delete(S, 1, 1);
  end;
  GetName := (Name <> '');
end;

function HasExtension(Name : String; var DotPos : Word) : Boolean;
  {-Return whether and position of extension separator dot in a pathname}
var
  I : Word;
begin
  DotPos := 0;
  for I := Length(Name) downto 1 do
    if (Name[I] = '.') and (DotPos = 0) then
      DotPos := I;
  HasExtension := (DotPos > 0) and (Pos('\', Copy(Name, Succ(DotPos), 64)) = 0);
end;

function ForceExtension(Name, Ext : String) : String;
  {-Return a pathname with the specified extension attached}
var
  DotPos : Word;
begin
  if HasExtension(Name, DotPos) then
    ForceExtension := Copy(Name, 1, DotPos)+Ext
  else
    ForceExtension := Name+'.'+Ext;
end;

procedure WriteHelp;
  {-Display help information and halt}
begin
  WriteLn;
  WriteLn('Usage: OVRACTR [Options] InputName [>OutputFile]');
  WriteLn;
  WriteLn('  OVRACTR must read:');
  WriteLn('    InputName.MAP - symbol file for segment information.');
  WriteLn('    InputName.OVD - overlay data file produced by OVRACT.');
  WriteLn;
  WriteLn('Options:');
  WriteLn('  /Q    Quiet mode. No status output while processing.');
  WriteLn('  /D    Detail report showing all overlay activity.');
  WriteLn('  /S    Summary report showing statistics for each unit.');
  WriteLn('  /O    Summary report showing statistics only for overlaid units.');
  WriteLn;
  WriteLn('  At least one report option must be specified');
  Halt(1);
end;

function ExistFile(FName : String) : Boolean;
  {-Return true if file exists}
var
  F : file;
begin
  Assign(F, FName);
  Reset(F);
  if IoResult = 0 then begin
    ExistFile := True;
    Close(F);
  end else
    ExistFile := False;
end;

procedure ValidateInput;
  {-Get working filenames and assure files exist}
var
  Iroot : PathStr;
  Arg : String;
  I : Integer;
begin
  {Get parameters}
  Iroot := '';
  I := 1;
  while I <= ParamCount do begin
    Arg := StUpcase(ParamStr(I));
    if (Arg = '/Q') or (Arg = '-Q') then
      ShowStatus := False
    else if (Arg = '/D') or (Arg = '-D') then
      ShowDetail := True
    else if (Arg = '/S') or (Arg = '-S') then
      ShowSummary := True
    else if (Arg = '/O') or (Arg = '-O') then begin
      ShowSummary := True;
      OverlaysOnly := True;
    end
    else if Iroot = '' then
      Iroot := Arg
    else
      Error('Too many filenames on command line');
    Inc(I);
  end;
  if (Iroot = '') or not (ShowDetail or ShowSummary) then
    WriteHelp;

  {Build working filenames}
  Dname := ForceExtension(Iroot, 'OVD');
  Mname := ForceExtension(Iroot, 'MAP');

  {Make sure files are OK}
  if not ExistFile(Dname) then
    Error('OVD file '+Dname+' not found');
  if not ExistFile(Mname) then
    Error('MAP file '+Mname+' not found');
end;

procedure ParseMapFile(FName : String);
  {-Read and parse the MAP file, guaranteed to exist}
var
  F : Text;
  S : String;
  StatStart : LongInt;
  SegType : String;
  Tlong : LongInt;
  ParseState : (Unknown, Segments, Done);
begin

  {Open up the MAP file for reading}
  Assign(F, FName);
  SetTextBuf(F, Buffer, BufSize);
  Reset(F);
  if IoResult <> 0 then
    Error('Error opening '+FName);

  if ShowStatus then
    WriteLn(StdErr, 'Parsing MAP file');

  {Parse the segment description section only}
  UnitCount := 0;
  ParseState := Unknown;
  repeat
    ReadLn(F, S);
    if IoResult <> 0 then
      Error('Error reading '+FName);
    S := StUpcase(Trim(S));
    if S <> '' then
      if Pos('START', S) = 1 then
        ParseState := Segments
      else if Pos('ADDRESS', S) = 1 then
        ParseState := Done
      else if ParseState = Segments then begin
        {Parse the line to get the unit description}
        Inc(UnitCount);
        if UnitCount > MaxUnits then
          Error('Cannot exceed '+Long2Str(MaxUnits)+' segments');
        FillChar(Units[UnitCount], SizeOf(UnitRecord), 0);

        with Units[UnitCount] do begin

          {Get the position and size of the unit in the EXE image}
          if not GetLong(S, StatStart) then
            InvalidMapError;
          StatSeg := StatStart shr 4;
          {Ignore the end of the segment}
          if not GetLong(S, Tlong) then
            InvalidMapError;
          {Get the length of the segment}
          if not GetLong(S, StatLen) then
            InvalidMapError;

          {Get the name of the segment}
          if not GetName(S, Name) then
            InvalidMapError;

          {Some segments are not really in the EXE file}
          if not GetName(S, SegType) then
            InvalidMapError;
          if SegType = 'CODE' then
            SegClass := 0
          else if SegType = 'DATA' then
            SegClass := 1
          else if SegType = 'STACK' then
            SegClass := 2
          else if SegType = 'HEAP' then
            SegClass := 3
          else
            SegClass := 4;
        end;
      end;
  until (ParseState = Done) or EoF(F);
  Close(F);
end;

function ReadWord : Word;
var
  W : Word;
begin
  if EOF (OvrDataFile) then
    Error ('Unexpected EOF on ' + Dname);
  Read (OvrDataFile, W);
  ReadWord := W;
end;

function LookupSeg (S : Word) : Integer;
var
  I : Integer;
begin
  for I := 1 to UnitCount do
    if (S = Units[I].StatSeg) and (Units[I].StatLen > 0) then begin
      LookUpSeg := I;
      exit;
    end;
  LookUpSeg := 0;
end;

function NextPara(Bytes : LongInt) : LongInt;
  {-Round up to next paragraph}
begin
  NextPara := (Bytes+15) and $FFFFFFF0;
end;

procedure ProcessCodeList;
var
  StaticSeg : Word;
begin
  StaticSeg := ReadWord;
  while StaticSeg <> 0 do begin
    with Units[LookupSeg(StaticSeg)] do begin
      with Long(FileOfs) do begin
        LowWord := ReadWord;
        HighWord := ReadWord;
      end;
      CodeSize := NextPara(ReadWord);
      FixupSize := NextPara(ReadWord);
      EntryPts := ReadWord;
    end;
    StaticSeg := ReadWord;
  end;
end;

function FormatTime (T : LongInt) : string;
const
  Divisor = 119318.0/65536;
var
  Tenths : LongInt;
  Minutes, I : Integer;
  S : string[8];
  Secs : string[3];
begin
  Tenths := Round (T / Divisor);
  Minutes := Tenths div 600;
  Tenths := Tenths mod 600;
  Str (Minutes:3, S);
  Str (Tenths:3, Secs);
  S := S + ':' + Secs;
  for I := 1 to 6 do
    if S[I] = ' ' then
      S[I] := '0';
  Insert ('.',S,7);
  FormatTime := S;
end;

procedure ChangeOverlayBuffer;
begin
  Ovr_Heap_Org := ReadWord;
  Ovr_Heap_End := ReadWord;
  if ShowDetail then
    Writeln ('Overlay buffer set to ',HexW(Ovr_Heap_Org),'-',HexW(Ovr_Heap_End));
end;

procedure PrintLoadList (W : Word);
var
  I : Integer;
  OutSize : Integer;   { Count of characters written on current line }
  Name : UnitNameStr;
  StaticSeg,
  LoadSeg : Word;
  OvrSeg : Word;  { Static segment of unit just loaded }
  OvrOfs : Word;  { Offset of procedure within the unit's static segment }
begin
  OvrSeg := W;
  OvrOfs := ReadWord;
  StaticSeg := ReadWord;
  I := LookupSeg (OvrSeg - PSP - $10);
  if ShowDetail then
    Write (FormatTime (Time),': ', Units[I].Name, '.', HexW(OvrOfs), ' called');
  if StaticSeg = 0 then begin
    { there is no load list, must be a reprieve }
    if ShowDetail then
      Writeln (' (reprieved)');
    Inc(Units[I].ReprieveCount);
  end
  else begin
    { load list follows }
    Inc(Units[I].LoadCount);
    if ShowDetail then begin
      Writeln (' (loaded)');
      Write ('  load list: ');
      OutSize := 13;
    end;
    while StaticSeg <> 0 do begin
      LoadSeg := ReadWord;
      if ShowDetail then begin
        Name := Units[LookupSeg(StaticSeg-PSP-$10)].Name;
        if OutSize + Length(Name) + 2 > 79 then begin
          Writeln;
          Write ('  ');
          OutSize := 2;
        end;
        Write (Name,'  ');
        Inc(OutSize,Length(Name) + 2);
      end;
      StaticSeg := ReadWord;
    end;
    if ShowDetail then
      Writeln;
  end;
end;

procedure ProcessOverlayData (Name : PathStr);
const
  EndListMark : Word = 0;
  OvrHeapMark : Word = $FFFF;
var
  W : Word;
begin
  assign(OvrDataFile,Name);
  {$I-}
  reset(OvrDataFile);
  {$I+}
  if IOResult <> 0 then
    Error ('Could not open '+Name+' for input')
  else begin
    if ShowStatus then
      WriteLn(StdErr, 'Reading OVD file');
    if ReadWord <> 1 then
      Error ('OVD file version mismatch');
    PSP := ReadWord;
    ProcessCodeList;
    while not EOF (OvrDataFile) do begin
      with Long(Time) do begin
        LowWord := ReadWord;
        HighWord := ReadWord;
      end;
      W := ReadWord;
      if W = OvrHeapMark then begin
        ChangeOverlayBuffer;
        W := ReadWord;
      end;
      PrintLoadList (W);
    end;
  end;
end;

procedure WriteUnitInfo;
var
  V : Word;
begin
  WriteLn;
  WriteLn(
'UNIT STATISTICS');
  WriteLn(
'                Static  Static  Overlay  Fixup   Entry  Overlay  Load  Reprieve');
  WriteLn(
'Segment name   Segment    Size    Size    Size  Points  FilePos  Count  Count');
  WriteLn(
'==============  ======   =====   =====   =====   =====  =======  =====  =====');
{xxxxxxxxxxxxxxx 0FFFFh   ddddd   ddddd   ddddd   ddddd  0FFFFFh  ddddd  ddddd}

  for V := 1 to UnitCount do
    with Units[V] do
      if (StatLen > 0) and (not OverlaysOnly or (CodeSize > 0)) then begin
        Write(Pad(Name, NameSize+1),
              '0', HexW(StatSeg), 'h   ',
              StatLen:5, '   ');

        if CodeSize > 0 then begin
          { Overlaid Unit }
          Write(CodeSize:5, '   ',
                FixupSize:5, '   ',
                EntryPts:5, '  ',
                Copy(HexL(FileOfs), 3, 6), 'h  ',
                LoadCount:5, '  ',
                ReprieveCount:5);

        end else begin
          {Non-overlaid unit or other segment}
          Write('    -       -       -        -      -      -');
        end;
        WriteLn;
      end;
end;

begin
  {Open standard error device}
  OpenStdErr;

  {Display copyright}
  WriteCopyRight;

  {Get filenames and assure they exist}
  ValidateInput;

  {Parse MAP file to get segment names and locations}
  ParseMapFile(Mname);

  {Read overlay data file}
  ProcessOverlayData(Dname);

  {Write information}
  if ShowSummary then
    WriteUnitInfo;
end.